module Vote.TH.Opaleye where

import Control.Exception (throw)
import Control.Monad (MonadFail (fail))
import Data.Maybe (fromJust)
import Data.String (String)
import Data.Tuple.Extra (fst3, thd3)
import Language.Haskell.TH
import Opaleye (InferrableTableField (..), Table, table)
import Protolude
import Vote.Internal.Util (lowerFirst)

{-
> :set -XTemplateHaskell
> $(stringE . show =<< reify ''Hello)
-}

-- newtype Hello = Hello (PropS "id" Int64 (Field SqlInt8))

-- makeTable ''Hello

-- data S = S (PropS "id" Int64 (Field SqlInt8)) (PropS "info" Text (Field SqlText)) (PropD "type" Text (Maybe (Field SqlText)) (Field SqlText))

-- makeTable ''S

data PropS (a :: Symbol) b c = PropS b c

data PropD (a :: Symbol) b c d = PropD b c d

newtype MakeTableException = MakeTableException String deriving (Show)

instance Exception MakeTableException

makeTable :: String -> Name -> Q [Dec]
makeTable tblName typName = do
  mTypName <- lookupTypeName (nameBase typName)
  when (isNothing mTypName) . fail $ "makeTable: type '" <> nameBase typName <> "' not found"
  tInfo <- reify (fromJust mTypName)
  bangs <- case tInfo of
    TyConI (DataD _ _ _ _ [NormalC _ bangs] _) -> return bangs
    TyConI (NewtypeD _ _ _ _ (NormalC _ bangs) _) -> return bangs
    _ -> fail "makeTable: type constructor not supported"
  let funName = (lowerFirst . nameBase $ typName) <> "Table"
  let tTups = bangToTup <$> bangs
  let wTyps = fst . thd3 <$> tTups
  let wFlds = genSigFields wTyps Nothing
  let vTyps = snd . thd3 <$> tTups
  let vFlds = genSigFields vTyps Nothing
  sig <- sigD (mkName funName) (appT (appT (conT ''Table) wFlds) vFlds)
  let nFlds = fst3 <$> tTups
  let eFlds = appE (varE 'tableField) . litE . stringL <$> nFlds
  fun <- funD (mkName funName) [clause [] (normalB (appE (appE (varE 'table) (litE (stringL tblName))) (appE (varE (mkName $ "p" <> (show . length $ nFlds))) (genFunFields eFlds)))) []]
  return [sig, fun]
  where
    bangToTup (_, AppT (AppT (AppT (ConT pName) (LitT (StrTyLit lbl))) rTyp) tTyp) | pName == ''PropS = (lbl, rTyp, (tTyp, tTyp))
    bangToTup (_, AppT (AppT (AppT (AppT (ConT pName) (LitT (StrTyLit lbl))) rTyp) wTyp) vTyp) | pName == ''PropD = (lbl, rTyp, (wTyp, vTyp))
    bangToTup _ = throw $ MakeTableException "makeTable: bang type not supported"
    genSigFields (t : ts) Nothing = genSigFields ts (Just $ if null ts then t else AppT (TupleT $ length ts + 1) t)
    genSigFields (t : ts) (Just t') = genSigFields ts (Just (AppT t' t))
    genSigFields [] (Just t') = return t'
    genSigFields [] Nothing = return $ ConT ''()
    genFunFields es | length es > 1 = tupE es
    genFunFields [e] = parensE e
    genFunFields _ = throw $ MakeTableException "makeTable: empty fields"
